
XPDDCS   ;SFISC/RSD - Display Checksum for a package ;05/05/2008
         ;;8.0;KERNEL;**2,44,108,202,393,511**;Jul 10, 1995;Build 5
         ;Per VHA Directive 2004-038, this routine should not be modified.
         Q
EN1      ;Verify checksums in Transport Global
         N D0,DIC,X,XPD,XPDS,XPDST,XPDT,Y,Z
         ;S DIC="^XPD(9.7,",DIC(0)="AEQMZ",DIC("S")="I $D(^XTMP(""XPDI"",Y))"
         ;D ^DIC Q:Y<0
         S XPDS="I $D(^XTMP(""XPDI"",Y))"
         S XPDST=$$LOOK^XPDI1(XPDS) Q:XPDST'>0
         S XPDSHW=$$ASK Q:$D(DIRUT)
         S XPD("XPDT(")="",XPD("XPDST")="",XPD("XPDSHW")="",X="XUTMDEVQ"
         ;during Virgin install, XUTMDEVQ might not exists
         X ^%ZOSF("TEST") E  D  Q
         .S IOSL=99999,IOM=80,IOF="#",IOST="",$Y=0 D LST1(9.7)
         S Y="LST1^XPDDCS(9.7)",Z="Checksum Print"
         ;p345-rename AND* to XPD* - Patch was Cancelled keep code for future.
         I '$G(XPDAUTO) D EN^XUTMDEVQ(Y,Z,.XPD)
         I $G(XPDAUTO) S IO=XPDDEV U XPDDEV D LST1^XPDDCS(9.7)
         Q
         ;
ASK()    ;Ask if want each routine listed
         N DIR
         I $D(XPDAUTO) Q 1
         S DIR(0)="YAO",DIR("A")="Want each Routine Listed with Checksums: ",DIR("A",1)="",DIR("B")="Yes"
         D ^DIR
         Q Y
         ;
EN2      ;print from build (system)
         N D0,DIC,XPD,XPDT,XPDST,Y,Z
         ;S DIC="^XPD(9.6,",DIC(0)="AEQMZ"
         ;D ^DIC Q:Y<0
         S XPDST=$$LOOK^XPDB1() Q:XPDST'>0
         S XPDSHW=$$ASK Q:$D(DIRUT)
         S XPD("XPDT(")="",XPD("XPDSHW")="",Y="LST1^XPDDCS(9.6)",Z="Checksum Print"
         ;p345-rename AND* to XPD*- Patch was Cancelled keep code for future.
         I '$G(XPDAUTO) D EN^XUTMDEVQ(Y,Z,.XPD)
         I $G(XPDAUTO) S:'$D(XPDDEV) XPDDEV=0 U XPDDEV D LST1^XPDDCS(9.6)
         Q
         ;
LST1(FILE) ;Print group
         N XPDI S XPDI=0
         F  S XPDI=$O(XPDT(XPDI)) Q:XPDI'>0  S D0=+XPDT(XPDI) D PNT(FILE)
         Q
         ;
PNT(XPDFIL) ;print
         N XPD0,XPDC,XPDDT,XPDE,XPDI,XPDJ,XPDPG,XPDQ,XPDUL,X
         Q:'$D(^XPD(XPDFIL,D0,0))  S XPD0=^(0),XPDPG=1,$P(XPDUL,"-",IOM)="",XPDDT=$$HTE^XLFDT($H,"1PM")
         W:$E(IOST,1,2)="C-" @IOF D HDR
         W !
         S XPDI="",(XPDQ,XPDE)=0
         ;XPDFIL=9.7  use transport global exists
         I XPDFIL=9.7 D
         .I '$D(^XTMP("XPDI",D0)) W !!," ** Transport Global doesn't exist **" S XPDQ=1 Q
         .;check for missing nodes in transport global
         .I '$D(^XTMP("XPDI",D0,"BLD"))="" W !!," **Transport Global corrupted,please reload **" S XPDQ=1 Q
         .F XPDC=0:1 S XPDI=$O(^XTMP("XPDI",D0,"RTN",XPDI)) Q:XPDI=""  S XPDJ=$G(^(XPDI)) D  Q:XPDQ
         ..I XPDJ="" W !," **Transport Global corrupted, please reload **" S XPDQ=1 Q
         ..;if deleting at site, there is no checksum
         ..I +XPDJ=1 S XPDC=XPDC-1 Q
         ..D SUM(XPDI,$NA(^XTMP("XPDI",D0,"RTN",XPDI)),$P(XPDJ,U,3),$P(XPDJ,U,4))
         ..S XPDQ=$$CHK(4)
         ;check build file
         E  D
         .F XPDC=0:1 S XPDI=$O(^XPD(9.6,D0,"KRN",9.8,"NM","B",XPDI)) Q:XPDI="" S XPDJ=$O(^(XPDI,0)) D  Q:XPDQ
         ..Q:'$D(^XPD(9.6,D0,"KRN",9.8,"NM",+XPDJ,0))  S XPDJ=$P(^(0),U,4)
         ..;quit if no checksum, routine wasn't loaded
         ..I XPDJ="" S XPDC=XPDC-1 Q
         ..N DIF,XCNP,%N
         ..S X=XPDI,DIF="^TMP($J,""RTN"",XPDI,",XCNP=0
         ..X ^%ZOSF("TEST") E  W !,XPDI,?10,"Doesn't Exist" Q
         ..X ^%ZOSF("LOAD")
         ..D SUM(XPDI,$NA(^TMP($J,"RTN",XPDI)),XPDJ,"")
         ..S XPDQ=$$CHK(4)
         Q:XPDQ
         W !!?3,XPDC," Routine"_$S(XPDC>1:"s",1:"")_" checked, ",XPDE," failed.",!
         ;p345-rename AND* to XPD*-Patch was Cancelled keep code for future.
         I $G(XPDAUTO) S XPDCHKSM=XPDE
         Q
         ;
         ;XPDR=routine name, Z=global root, XPD=check sum, XPDBS=before Checksum from FORUM SUM(XPDR,Z,XPD,XPDBS) ;check checksum
         N Y
         ;See if we have a before checksum and compare.
         I $L(XPDBS) D BEFORE(XPDR,XPDBS)
         ;first char. is the sum tag used in XPDRSUM
         I XPD'?1U1.N W !,XPDR,?10,"ERROR in Checksum" S XPDE=XPDE+1 Q
         S @("Y=$$SUM"_$E(XPD)_"^XPDRSUM(Z)"),XPD=$E(XPD,2,255)
         I Y=XPD,XPDSHW W !,XPDR,?10,"Calculated "_$J(XPD,10)
         I Y'=XPD W !,XPDR,?10,"Calculated "_$C(7)_$J(Y,10)_", expected value "_XPD S XPDE=XPDE+1
         Q
         ;
BEFORE(RN,SUM) ;Check a before Checksum
         N DIF,XCNP,%N,X
         I SUM'?1U1.N Q
         K ^TMP($J,"XPDDCS",RN) ;patch 511
         S X=RN,DIF="^TMP($J,""XPDDCS"",RN,",XCNP=0
         X ^%ZOSF("TEST") E  W !,RN,?10,"Not on current system." Q
         X ^%ZOSF("LOAD")
         S DIF=$NA(^TMP($J,"XPDDCS",RN))
         S @("Y=$$SUM"_$E(SUM)_"^XPDRSUM(DIF)"),SUM=$E(SUM,2,255)
         I Y'=SUM W !,RN,?10,"Before Checksum Calculated "_Y_" expected value "_SUM
         Q
         ;
CHK(Y)   ;Y=excess lines, return 1 to exit
         Q:$Y<(IOSL-Y) 0
         I $E(IOST,1,2)="C-" D  Q:'Y 1
         .N DIR,I,J,K,X
         .S DIR(0)="E" D ^DIR
         S XPDPG=XPDPG+1
         W @IOF D HDR
         Q 0
         ;
HDR      W !,"PACKAGE: ",$P(XPD0,U),"     ",XPDDT,?70,"PAGE ",XPDPG,!,XPDUL,!
         Q



XPDIL1   ;SFISC/RSD - cont. of load Distribution Global ;05/05/2008
         ;;8.0;KERNEL;**15,17,39,41,44,66,68,76,85,100,108,229,525**;Jul 10, 1995;Build 10
         ; Per VHA Directive 2004-038, this routine should not be modified.
         ;
PKG(XPDA) ;check Package file
         N XPD,XPDCP,XPDNM,XPDNOQUE,XPDPKG,X,Y,%
         S XPDNM=$P(XPDT(XPDIT),U,2) W !?3,XPDNM
         ;check KIDS version against sites version, skip if package is Kernel
         I $$PKG^XPDUTL(XPDNM)'["KERNEL" D  I $D(XPDQUIT) D ABORT^XPDI(XPDA,1) Q
         .;this is part of a Kernel multi package
         .Q:$O(XPDT("NM","KERNEL"))["KERNEL"
         .S Y=$G(^XTMP("XPDI",XPDA,"VER"))
         .I $$VERSION^XPDUTL("XU")<Y W !!,"But I need Version ",+Y," of KERNEL!"  S XPDQUIT=1
         .I $$VERSION^XPDUTL("VA FILEMAN")<$P(Y,U,2) W !,"But I Need Version ",+$P(Y,U,2)," of VA FILEMAN!" S XPDQUIT=1
         ;get national package name
         S %=$O(^XTMP("XPDI",XPDA,"PKG",0)),XPDPKG(0)=$G(^(+%,0)),XPDPKG=%
         ;XPDPKG=new ien^old ien
         I XPDPKG D  S XPDPKG=+Y_U_XPDPKG
         .N D,DIC
         .S DIC="^DIC(9.4,",DIC(0)="X",X=$P(XPDPKG(0),U)
         .D ^DIC Q:Y>0
         .;if lookup fails try C & C2 x-ref
         .S X=$P(XPDPKG(0),U,2),DIC(0)="MX",D="C^C2" D MIX^DIC1
         ;add package to Install file
         I XPDPKG>0 S XPD(9.7,XPDA_",",1)=+XPDPKG D FILE^DIE("","XPD")
         ;XPDSKPE= does site want to run Environ. Check
         I '$G(XPDSKPE) Q:$$ENV(0)=1
         ;global package can't have pre or post inits
         Q:$D(XPDGP)
         ;create pre-init checkpoint
         S XPDCP="INI" I '$$NEWCP^XPDUTL("XPD PREINSTALL COMPLETED") D ABORT^XPDI(XPDA,1) Q
         S %=$$INRTN("INI")
         ;check for routine, use as call back
         I $L(%),'$$NEWCP^XPDUTL("XPD PREINSTALL STARTED",%) D ABORT^XPDI(XPDA,1) Q
         ;create post-init checkpoint
         S XPDCP="INIT" I '$$NEWCP^XPDUTL("XPD POSTINSTALL COMPLETED") D ABORT^XPDI(XPDA,1) Q
         S %=$$INRTN("INIT")
         I $L(%),'$$NEWCP^XPDUTL("XPD POSTINSTALL STARTED",%) D ABORT^XPDI(XPDA,1) Q
         ;create fileman and components check points and file rest of data
         D XPCK^XPDIK("FIA"),XPCK^XPDIK("KRN")
         Q
INST(XPDNM) ;add to Install file
         N %X,DIC,DIR,DIRUT,DLAYGO,X,XPD,XPDA,XPDIE,XPDDIQ,Y,SH
         ;check if Build was already installed
         ;XPD=0 abort install, else XPD=ien in Install file
         I $D(^XPD(9.7,"B",XPDNM)) S (SH,Y)=0 D  Q:$D(XPD) XPD
         . W !,"Build ",XPDNM," has been loaded before, here is when: "
         . F  S Y=$O(^XPD(9.7,"B",XPDNM,Y)) Q:'Y  D
         .. Q:'$D(^XPD(9.7,Y,0))  S %=^(0)
         .. W !?6,$P(%,U),"   "
         .. I $P(%,U,9)<3,$D(^XTMP("XPDI",Y)) W "**Transport Global already exists**",*7 S XPD=0 Q
         .. S %X=$X W $$EXTERNAL^DILFD(9.7,.02,"",$P(%,U,9)),!?%X,"was loaded on ",$$FMTE^XLFDT($P($G(^XPD(9.7,Y,1)),U))
         . ;quit if transport global exist
         . Q:$D(XPD)
         . S DIR(0)="Y",DIR("A")="OK to continue with Load",DIR("B")="NO"
         . D ^DIR W ! I $D(DIRUT)!'Y S XPD=0 Q
         S DIC="^XPD(9.7,",DIC(0)="XL",DLAYGO=9.7,X=""""_XPDNM_""""
         ;add to Install file, must be new
         D ^DIC
         I Y<0 S SH=0 W !,"Can't add Build ",XPDNM," to Install File" Q 0
         ;set starting package to Y, if it is not already defined
         S:'XPDST XPDST=+Y
         ;XPDT array keeps track of all packages in this distribution
         S XPDA=+Y,XPDT(XPDIT)=XPDA_U_XPDNM,(XPDT("DA",XPDA),XPDT("NM",XPDNM))=XPDIT
         S %="XPDIE(9.7,"""_XPDA_","")",@%@(.02)=0,@%@(2)=$$NOW^XLFDT,@%@(3)=XPDST,@%@(4)=XPDIT,@%@(5)="",@%@(6)=XPDST("H1")
         D FILE^DIE("","XPDIE")
         I '$D(SH) W !?3,XPDNM ;SH is set when some other part of INST shows the name
         Q XPDA
         ;
         ;XPDQUIT quit current package install, 1=kill global, 2=leave global
         ;XPDQUIT(package) quit package install, 1=kill, 2=leave
         ;XPDABORT quit the entire distribution, 1=kill, 2=leave
         ;XPDENV 0=loading distribution, 1=installing
ENV(XPDENV) ;environment check & version check
         ;returns 0=ok, 1=rejected kill global, 2=rejected leave global
         N %,DIR,XPDI,XPDQUIT,XPDABORT,XPDDONE,XPDGREF,XPDMBREQ
         M X=DUZ N DUZ M DUZ=X S DUZ(0)="@" ;See that ENV check has full FM priv.
         S XPDGREF="^XTMP(""XPDI"","_XPDA_",""TEMP"")"
         S XPDMBREQ=$G(^XTMP("XPDI",XPDA,"MBREQ"))
         S $P(^XPD(9.7,XPDA,0),U,7)=XPDMBREQ
         ;check version number
         I XPDPKG>0 D  I $G(XPDQUIT) D ABORT^XPDI(XPDA,1) Q 1
         .N DIR,DIRUT,X,Y
         .S %=+$$VER^XPDUTL(XPDNM),Y=+$G(^DIC(9.4,+XPDPKG,"VERSION")),X=XPDNM["*"
         .;if patch, version must be the same
         .I X,%'=Y W !,"This Patch is for Version ",%,", you are running Version ",Y,! S XPDQUIT=1
         .;if package, version must be greater or equal
         .I 'X,%<Y W !,"You have a Version greater than mine!",! S XPDQUIT=1
         .Q:'$G(XPDQUIT)
         .I $G(XPDMBREQ) D  S XPDQUIT=0,XPDDONE=1 Q
         . . D MES^XPDUTL("**ABORT** Required Build "_XPDNM_", did not pass internal KIDS checks!"),ABRTALL^XPDI(1),NONE^XPDI
         . . Q
         .S DIR(0)="Y",DIR("A")="Want to continue installing this build",DIR("B")="NO"
         .D ^DIR I Y K XPDQUIT
         .Q
         Q:$G(XPDDONE) 1
         S %=$$REQB I % S (XPDABORT,XPDREQAB)=% G ABORT
         S %=$G(^XTMP("XPDI",XPDA,"PRE")) D:%]""
         .W !,"Will first run the Environment Check Routine, ",%,!
         .D SAVE^XPDIJ(%),@("^"_%)
ABORT    I $G(XPDABORT) D  Q XPDABORT
         .;if during load & leave global quit
         .I 'XPDENV,XPDABORT=2 Q
         .D ABRTALL^XPDI(XPDABORT)
         Q:'$D(XPDQUIT) 0
         I $G(XPDQUIT) D ABORT^XPDI(XPDA,XPDQUIT)
         S XPDI=""
         ;don't do if loading & leave global, need to keep XPDT(array)
         F  S XPDI=$O(XPDQUIT(XPDI)) Q:XPDI=""  D:'(XPDQUIT(XPDI)=2&'XPDENV)
         .S %=$G(XPDT("NM",XPDI)) D:% ABORT^XPDI(+XPDT(%),XPDQUIT(XPDI))
         S XPDQUIT=$S($G(XPDQUIT):XPDQUIT,'$O(XPDT(0))!'$D(^XTMP("XPDI",XPDA)):1,1:0)
         Q XPDQUIT
         ;
REQB()   ;check for Required Builds
         ;returns 0=ok, 1=failed kill global, 2=failed leave global
         N XPDACT,XPDBLD,XPDI,XPDQ,XPDQUIT,XPDX,XPDX0,X,Y
         S XPDBLD=$O(^XTMP("XPDI",XPDA,"BLD",0)),XPDQUIT=0,XPDI=0
         Q:'$D(^XTMP("XPDI",XPDA,"BLD",XPDBLD,"REQB")) 0
         F  S XPDI=$O(^XTMP("XPDI",XPDA,"BLD",XPDBLD,"REQB",XPDI)) Q:'XPDI  S XPDX0=^(XPDI,0) D
         .S XPDQ=0,XPDX=$P(XPDX0,U),XPDACT=$P(XPDX0,U,2),X=$$PKG^XPDUTL(XPDX),Y=$$VER^XPDUTL(XPDX),Z=$$VERSION^XPDUTL(X)
         .;quit if current version is greater than what we are checking for
         .Q:Z>Y
         .I XPDX'["*" S:Z<Y XPDQ=2
         .E  S:'$$PATCH^XPDUTL(XPDX) XPDQ=1
         .;quit if patch is already on system
         .Q:'XPDQ
         .;quit if patch is sequenced prior within this build 
         .I $D(XPDT("NM",XPDX)),(XPDT("NM",XPDX)<XPDT("NM",XPDNM)) S XPDQ=0 Q
         .S XPDQUIT=$S(XPDACT>XPDQUIT:XPDACT,1:XPDQUIT)
         .;XPDACT=0 warning, =1 abort & kill global, =2 abort
         .W !!,$S(XPDACT:"**INSTALL ABORTED**",1:"**WARNING**")_$S(XPDQ=1:" Patch ",1:" Package ")_XPDX_" is Required "_$S(XPDACT:"to install",1:"for")_" this package!!",!
         Q:'XPDQUIT 0
         ;don't do if leave global and loading
         D:'(XPDQUIT=2&'XPDENV) ABORT^XPDI(XPDA,XPDQUIT)
         Q XPDQUIT
         ;
         ;return a routine that can be run
INRTN(X) N Y
         S Y=$G(^XTMP("XPDI",XPDA,X)) Q:Y="" ""
         S Y=$S(Y["^":Y,1:"^"_Y)
         Q Y


XPDIQ    ;SFISC/RSD - Install Questions ;03/21/2008
         ;;8.0;KERNEL;**21,28,58,61,95,108,399**;Jul 10, 1995;Build 12
         Q
DIR(XPFR,XPFP) ;XPFR=prefix, XPFP=file no._# or Mail Group ien
         ;XPFP is for XPF  or XPM questions
         N DIR,DR,XPDI,XPDJ,X,Y,Z
         S XPFP=$G(XPFP),XPDI=$S(XPFP:XPFR_XPFP,1:XPFR)
         D QUES(XPDI)
         ;ask questions
         S X=XPFR
         F  S X=$O(^XTMP("XPDI",XPDA,"QUES",X)),Z="" Q:X=""!($P(X,XPFR)]"")  D  I $D(DIRUT) S XPDQUIT=1 Q
         .S XPDJ=$S('XPFP:X,1:XPDI_$P(X,XPFR,2))
         .F  S Z=$O(^XTMP("XPDI",XPDA,"QUES",X,Z)) Q:Z=""  M DIR(Z)=^(Z)
         .;if there was a previous answer, reset DIR("B") to external or internal answer
         .S:$L($G(XPDQUES(XPDJ))) DIR("B")=$G(XPDQUES(XPDJ,"B"),XPDQUES(XPDJ)) D  Q:'$D(Y)
         ..N FLAG,X,Z K Y
         ..;this is the M CODE node that was set to DIR("M") in prev for loop
         ..;FLAG is used by KIDS questions
         ..I $D(DIR("M")) S %=DIR("M"),FLAG="" K DIR("M") X %
         ..Q:'$D(DIR)
         ..;'|' is used to mark variable in prompt, reset prompt with value of variable
         ..S:$G(DIR("A"))["|" DIR("A")=$P(DIR("A"),"|")_@$P(DIR("A"),"|",2)_$P(DIR("A"),"|",3)
         ..K:$G(DIR("B"))="" DIR("B")
         ..D ^DIR
         .S %=$P(DIR(0),U)
         .;read was optional and didn't timeout and user didn't enter anything
         .I %["O",'$D(DTOUT),$S(%["P":Y=-1,1:Y="") K DIRUT Q
         .;quit if the user up-arrowed out
         .Q:$D(DIRUT)
         .;if pointer, reset Y & Y(0)
         .I %["P" S Y(0)=$S(%["Z":$P(Y(0),U),1:$P(Y,U,2)),Y=+Y
         .;if Y(0) is not defined, but Y is
         .S:$D(Y)#2&'($D(Y(0))#2) Y(0)=Y
         .S XPDQUES(XPDJ)=Y,XPDQUES(XPDJ,"A")=$G(DIR("A")),XPDQUES(XPDJ,"B")=$G(Y(0))
         .K DIR
         K XPDJ S XPDI=XPFR
         ;code to save XPDQUES to INSTALL ANSWERS in file 9.7, loop thru the answers starting with the from value, XPFR
         F Y=1:1 S XPDI=$O(XPDQUES(XPDI)) Q:XPDI=""!($P(XPDI,XPFR)]"")  D
         .S X="XPDJ(9.701,""?+"_Y_","_XPDA_","")",@X@(.01)=XPDI,@X@(1)=$G(XPDQUES(XPDI,"A")),@X@(2)=$G(XPDQUES(XPDI,"B")),@X@(3)=XPDQUES(XPDI)
         K XPDI D:$D(XPDJ)>9 UPDATE^DIE("","XPDJ","XPDI")
         Q
         ;
QUES(X)  ;build XPDQUES array, X="INI","INIT","XPF","XPM"
         ;move INSTALL ANSWERS from file 9.7 to XPDQUES
         ;XPDQUES(X)=internal answer, XPDQUES(X,"A")=prompt, XPDQUES(X,"B")=external answer.
         N Y,Z K XPDQUES S Z=X
         F  S Z=$O(^XPD(9.7,XPDA,"QUES","B",Z)) Q:Z=""!($P(Z,X)]"")  S Y=$O(^(Z,0)) D
         .Q:'$D(^XPD(9.7,XPDA,"QUES",Y,0))
         .S XPDQUES(Z)=$G(^(1)),XPDQUES(Z,"A")=$G(^("A")),XPDQUES(Z,"B")=$G(^("B")) ; ^(1) refer to prev line ^XPD(9.7,XPDA,"QUES","B",Z)
         Q
         ;
ANSWER(QUES) ;E.F. Return answer to question
         N IEN I '$D(XPDA)!($G(QUES)="") Q ""
         S IEN=$O(^XPD(9.7,XPDA,"QUES","B",QUES,0)) I IEN'>0 Q ""
         Q $G(^XPD(9.7,XPDA,"QUES",IEN,1))
         ;codes for install process questions
         ;XPDFIL=file #, XPDFILN=file name^global ref^partial DD
         ;XPDFILO=update DD^security codes^^^resolve pt^list template^data with file^add,merge,overwrite,replace^user override data update
         ;XPDSCR=screen to determine DD update
         ;XPDANS is define in QUES^XPDI
XPF1     ;write over existing file
         N XPDI
         W !!?3,XPDFIL,?13,$P(XPDFILN,U),$P("  (Partial Definition)",U,$P(XPDFILN,U,3)),$P("  (including data)",U,$P(XPDFILO,U,7)="y")
         ;file doesn't exists
         I XPDANS K DIR Q
         I $L($G(XPDSCR)) S XPDI=1 D  Q:'XPDI
         .X XPDSCR S XPDI=$T Q:XPDI
         .W !,"Data Dictionary FAILED the screening logic, file will NOT be installed!"
         .S $P(XPDANS,U,2)="1" K DIR
         S FLAG=$P($G(^DIC(XPDFIL,0)),U)
         ;file exist and has the same name
         I $P(FLAG,$P(XPDFILN,U))="" W !,"Note:  You already have the '",$P(XPDFILN,U),"' File." K DIR Q
         W *7,!,"*BUT YOU ALREADY HAVE '",FLAG,"' AS FILE #",XPDFIL,"!"
         S $P(XPDANS,U,4)=1
         Q
XPF2     ;data
         ;if they don't want to overwrite a file with a different name then set the DIRUT flag and ABORT, this will stop the rest of the questions and abort the install
         I $G(XPDQUES("XPF"_XPFP_1))=0 S DIRUT=1 K DIR Q
         ;if Data doesn't exists or DD failed screen or data wasn't sent, don't ask question
         I '$P(XPDANS,U,3)!$P(XPDANS,U,2)!($P(XPDFILO,U,7)'="y") K DIR Q
         S %=$F("amor",$P(XPDFILO,U,8))-1
         ;if this is add and file is not new
         I %=1 W !,"Data will NOT be added." K DIR Q
         ;check if dev. doesn't want to ask user
         I $P(XPDFILO,U,9)'="y" W !,"I will ",$P("^MERGE^OVERWRITE^REPLACE",U,%)," your data with mine." K DIR Q
         S FLAG=$P("^merged with^to overwrite^to replace",U,%)
         Q
         ;XPDDIQ(name)=internal value, (name,"A")=prompt, (name,"B")=external
XPQ(NM)  ;Build XPDDIQ
         Q:'$D(XPDDIQ(NM))
         I $D(XPDDIQ(NM))#2 S XPDQUES(NM)=XPDDIQ(NM) K DIR Q
         S:$D(XPDDIQ(NM,"A")) DIR("A")=XPDDIQ(NM,"A")
         S:$D(XPDDIQ(NM,"B")) DIR("B")=XPDDIQ(NM,"B")
         Q
XPI1     ;Inhibit Logons
         D XPQ("XPI1")
         Q
XPM1     ;mail groups
         S FLAG=XPDANS
         ;DIR("B") is null if first time here
         I DIR("B")="" D
         .;check if mail group already exist
         .S X=$$FIND1^DIC(3.8,"","XQf",XPDANS,"","","")
         .;get the current coordinator
         .Q:'X  S X=$P($G(^XMB(3.8,X,0)),U,7)
         .;set the default to current coordinator
         .I X,$D(^VA(200,X,0))#10 S DIR("B")=$P(^(0),U)
         D XPQ("XPM1")
         Q
XPO1     ;rebuild menu trees
         D XPQ("XPO1")
         Q
XPZ1     ;disable options
         D XPQ("XPZ1")
         Q
XPZ2     ;move routines
         N Y
         ;if they are not in production UCI don't ask
         X ^%ZOSF("UCI") I Y'=^%ZOSF("PROD") K DIR Q
         ;if they are not running MSM don't ask
         I ^%ZOSF("OS")'["MSM" K DIR Q
         Q:'$D(XPDDIQ("XPZ2"))
         I $D(XPDDIQ("XPZ2"))#2 S XPDQUES("XPZ2")=XPDDIQ("XPZ2") K DIR Q
         S:$D(XPDDIQ("XPZ2","A")) DIR("A")=XPDDIQ("XPZ2","A")
         S:$D(XPDDIQ("XPZ2","B")) DIR("B")=XPDDIQ("XPZ2","B")
         Q


XQOO     ;SEATTLE/LUKE - Out Of Order, Man ;9/13/96  09:21
         ;;8.0;KERNEL;**10,21,47,520**;Jul 03, 1995;Build 5
         ;Per VHA Directive  2004-038, this routine should not be modified.
INIT(XQSET) ;Call for Out-of-order set creation, called by KIDS
         ;
         ;The variable XQSET should be null if this is the first pass
         ;or if KIDS thinks the user wants a new set of options
         ;
         S XQINI="",XQK=0 ;XQINI used as a flag to see if it's KIDS calling
         I XQSET]"" S:'$D(^XTMP("XQOO",XQSET,0)) XQSET="^"
         I XQSET="^" G OUT
         I XQSET]"" S XQMESS=$P(^XTMP("XQOO",XQSET,0),U) G ASK1
         ;
EN       ;Entry point for Define Out Of Order Options Set option
         S XQK=0,U="^",XQSET=U
         ;
NAME     ;Get name for this option set
         W !!,"Enter a short name for this set of options and or protocols: " R XQSET:DTIME S:'$T XQSET=U G:XQSET=U OUT
         I XQSET="?" W !!,"Enter a name of 20 characters or less for this set, '^' to quit, or '??' for help" G NAME
         I XQSET["??" S XQH="XQOO-NAME" D EN^XQH G NAME
         I XQSET=""!($L(XQSET)>20) W !!,"Out-of-order sets must be named with 20 or less characters.  Enter '^' to quit." G NAME
         I $D(^XTMP("XQOO",XQSET,0)) D  G:$D(DIRUT) OUT G:Y=0 NAME G ASK1
         .S XQMESS=$P(^XTMP("XQOO",XQSET,0),U)
         .W !!,"WARNING: The Out-of-order set '",XQSET,"' already exists.",!
         .S DIR("A")="Do you want to modify it? (Y/N) " S DIR(0)="Y",DIR("B")="YES" D ^DIR K DIR
         .Q
         ;
MESS     ;Get the Out Of Order Message
         R !!,"What should the Out Of Order message text be? :",XQMESS:DTIME S:'$T XQMESS=U G:XQMESS=U OUT
         I XQMESS="?" W !!,"This is the message that will be shown with the options/protocols",!,"that are made out of order. For instance, ""Laboratory install in progress""" G MESS
         I XQMESS["??" S XQH="XQOO-MESS" D EN^XQH G MESS
         ;
ASK1     S XQFIL=19
ASK      ;Get options to mark
         S (XQ,XQN)=""
         W !!,"Enter "_$S(XQFIL=19:"options",1:"protocols")_" you wish to mark as 'Out Of Order': "
         R XQ:DTIME S:'$T XQ=U G:XQ=U OUT G:XQ="" SET
         I XQ="?" D  G ASK
         .W !!?5,"Enter "_$S(XQFIL=19:"an option",1:"a protocol")_" name,"
         .W !?5,"a name preceded by a minus sign to remove "_$S(XQFIL=19:"an option,",1:"a protocol,")
         .W !?5,$S(XQFIL=19:"'^PR'",1:"'^OP'")_" to switch to "_$S(XQFIL=19:"protocols,",1:"options,")
         .W !?5,"an uparrow (that is '^') to quit,"
         .W !?5,"or '??' for more help."
         .Q
         I XQ["??" S XQH="XQOO" D:XQ="??" EN^XQH D:XQ="???" LIST D:XQ="????" LSTFIL S XQH="XQOO-MAIN" D:XQ="?????" EN^XQH G ASK
         I $E(XQ,1,3)="^OP"!($E(XQ,1,3)="^op") S XQFIL=19,XQSWTCH="" G ASK
         I $E(XQ,1,3)="^PR"!($E(XQ,1,3)="^pr") S XQFIL=101,XQSWTCH="" G ASK
         S XQDEL=0 I $E(XQ,1)="-" S XQDEL=1,XQ=$E(XQ,2,99)
         I XQ="*",XQDEL K ^XTMP("XQOO",XQSET,XQFIL) W !," All "_$S(XQFIL=19:"options",1:"protocols")_" removed.  Start again or '^' to quit. " G ASK
         I XQ="*" S XQSTART=1,XQEND="ZZZZZ" D FIND G ASK
         I XQ?.E1"*" S XQSTART=$E(XQ,1,$L(XQ)-1),XQEND=XQSTART_$C(127) D FIND G 
ASK
         ;Get a range of options allowing for name with hyphens in them
         I XQ?1E.E1"-"1E.E S XQRNG=0 D  G:'XQRNG ASK
         .;Name has hyphen, echo back the name and quit
         .S X=XQ,DIC=XQFIL,DIC(0)="EZ" D ^DIC I Y>0 S XQ=$P(Y,U,2),XQRNG=1 Q
         .;It is a range, build prompt to verify range
         .W ! K DIR S DIR("A")="Do mean the "_$S(XQFIL=19:"options",1:"protocols")_" from "_$P(XQ,"-")_" to "_$P(XQ,"-",2)_"? (Y/N)",DIR(0)="YA" D ^DIR K DIR I Y S (XQN,XQSTART)=$P(XQ,"-",1),XQEND=$P(XQ,"-",2) D FIND
         .Q
         ;
         I XQ'?1E.E1"-"1E.E S X=XQ,DIC=XQFIL,DIC(0)="MEZ" D ^DIC S:Y'<0 XQ=$P(Y,U,2) I Y<0 W " ??",*7 G ASK
         I XQDEL K ^XTMP("XQOO",XQSET,XQFIL,+Y) G ASK
         S:$E(Y(0),1,4)'="XQOO" ^XTMP("XQOO",XQSET,XQFIL,+Y)=$P(Y(0),U)_U_$P(Y(0),U,2) G ASK
         ;
FIND     ;Find first option in wildcard list
         S XQN="" S:$L(XQSTART)>2 XQN=$E(XQSTART,1,$L(XQSTART)-1)
         I XQFIL=19 F XQI=0:0 S XQN=$O(^DIC(XQFIL,"B",XQN)) Q:XQN=""!($E(XQN,1,$L(XQSTART))=XQSTART)
         E  F XQI=0:0 S XQN=$O(^ORD(101,"B",XQN)) Q:XQN=""!($E(XQN,1,$L(XQSTART))=XQSTART)
         I XQN="" W !," No such ",$S(XQFIL=19:"option(s).",1:"protocol(s).") Q
         S XQSTART=XQN
         ;
FINDR    I XQFIL=19 S XQON=$O(^DIC(XQFIL,"B",XQN,0)),XQON0=^DIC(XQFIL,+XQON,0)
         E  S XQON=$O(^ORD(XQFIL,"B",XQN,0)),XQON0=^ORD(XQFIL,+XQON,0)
         I XQDEL D DELET Q
         ;
GET      ;Get the first option selected and put it in ^XTMP
         S XQN=XQSTART I $E(XQON,1,4)'="XQOO" S ^XTMP("XQOO",XQSET,XQFIL,+XQON)=$P(XQON0,U)_U_$P(XQON0,U,2),XQK=XQK+1
         S DIC=XQFIL,DIC(0)="MZ"
         ;
NEXT     ;Find the rest of the options in this range and do likewise
         I XQFIL=19 F  Q:XQN=XQEND  S XQN=$O(^DIC(XQFIL,"B",XQN)) Q:XQN=""!(XQN]XQEND)  S XQON=$O(^DIC(XQFIL,"B",XQN,0)),XQON0=^DIC(XQFIL,+XQON,0) I $E(XQON,1,4)'="XQOO" S ^XTMP("XQOO",XQSET,XQFIL,+XQON)=$P(XQON0,U)_U_$P(XQON0,U,2),XQK=XQK+1
         E  F  Q:XQN=XQEND  S XQN=$O(^ORD(XQFIL,"B",XQN)) Q:XQN=""!(XQN]XQEND)  S XQON=$O(^ORD(XQFIL,"B",XQN,0)),XQON0=^ORD(XQFIL,+XQON,0) I $E(XQON,1,4)'="XQOO" S ^XTMP("XQOO",XQSET,XQFIL,+XQON)=$P(XQON0,U)_U_$P(XQON0,U,2),XQK=XQK+1
         Q
         ;
DELET    ;Delete option(s) from the list in ^XTMP
         ;W !,XQON,"  ",XQSTART,"  ",XQDEL
         S XQN=XQSTART,XQDEL=0
         I XQFIL=19 F  K ^XTMP("XQOO",XQSET,XQFIL,+XQON) S XQN=$O(^DIC(XQFIL,"B",XQN)),XQX=XQK-1 Q:XQN=""!(XQN]XQEND)  S XQON=$O(^DIC(XQFIL,"B",XQN,0))
         E  F  K ^XTMP("XQOO",XQSET,XQFIL,+XQON) S XQN=$O(^ORD(XQFIL,"B",XQN)),XQX=XQK-1 Q:XQN=""!(XQN]XQEND)  S XQON=$O(^ORD(XQFIL,"B",XQN,0))
         Q
         ;
REMOV    R !!,"Remove all options previously selected? ",XQ:DTIME S:'$T XQ=U G:XQ[U OUT I XQ["N"!(XQ["n") W !!,"OK, you may continue." G ASK
         K ^XTMP("XQOO",XQSET)
         Q
LSTFIL   ;Show Option File
         N XQE,XQR,XQS
         D RANGE^XQOO2(.XQS,.XQE,.XQR) I XQR D BXREF^XQOO2(XQS,XQE)
         Q
         ;
LIST     ;List users and options selected so far.
         W @IOF S (XQT,XQM)=0
         F XQFIL0=19,101 D
         .S XQT=0,XQN=0,XQN=$O(^XTMP("XQOO",XQSET,XQFIL0,XQN)) I XQN="" W !!,"No "_$S(XQFIL0=19:"menu options",1:"protocols")_" selected yet" Q
         .W !!,"You will place Out Of Order the following "_$S(XQFIL0=19:"options:",1:"protocols:"),! F XQI=0:0 D:$Y+3>IOSL WAIT Q:XQ=U  W !,$P(^XTMP("XQOO",XQSET,XQFIL0,XQN),U,2)_"   ["_$P(^(XQN),U)_"]   (IEN = "_XQN_")" S XQN=$O(^(XQN)) Q:XQN=""
         .Q
         Q
         ;
WAIT     ;Skip to the head of the next page
         I 1 S XQ="" R:IOST["C-" !!,"Press RETURN to continue, or '^' to quit.",XQ:DTIME S:'$T XQ=U W @IOF
         Q
         ;
SET      ;Set 0th node in ^XTMP global
         I XQFIL=19,'$D(XQSWTCH) S XQFIL=101 G ASK
         D ^XQDATE
         I $D(^XTMP("XQOO",XQSET,0)) S XQMESS=$P(^(0),U)
         S ^XTMP("XQOO",XQSET,0)=XQMESS_U_%Y_U_$P(^VA(200,DUZ,0),",")
         S ^XTMP("XQOO",0)=DT_U_DT+7
         ;
OUT      ;Clean up
         ;
         I '$D(XPDNM),'$D(^XTMP("XQOO",XQSET,0)),$D(^XTMP("XQOO",XQSET)) D
         .;Temporary Fix: ^ at protocol prompt leaves partial set (no 0th node)
         .S DIR(0)="Y",DIR("B")="YES"
         .S DIR("A")="Delete this set of options? (Y/N) "
         .D ^DIR
         .I Y K ^XTMP("XQOO",XQSET)
         .E  D ^XQDATE S ^XTMP("XQOO",XQSET,0)=XQMESS_U_%Y_U_$P(^VA(200,DUZ,0),","),^XTMP("XQOO",0)=DT_U_DT+7
         .Q
         ;
         I '$D(XPDNM),$D(^XTMP("XQOO",XQSET,0)) D
         .S DIR(0)="Y",DIR("B")="NO"
         .S DIR("A")="Should I mark these options/protocols out-of-order now? (Y/N) "
         .D ^DIR I Y D OFF^XQOO1(XQSET)
         .Q
         ;
         K %,%Y,DIRUT,XQ,XQDEL,XQEND,XQFIL,XQFIL0,XQH,XQI,XQINI,XQK,XQM,XQMESS,XQN,XQON,XQON0,XQRNG,XQSTART,XQSWTCH,XQT,XQX,X,Y
         Q


